Language/OS - Multiplatform Resource Library

home *** CD-ROM | disk | FTP | other *** search

/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / forth / amiga / amigaker.arc / 14.compiler < prev next >

Wrap

Text File | 1987-12-30 | 19.5 KB | 516 lines

; ; 14.compiler ; ; * topstack (s -- n ) This constant is initialized at the start, and ; is used to do stack checking. dc.w -1 dc.l link0 link0 set *-4 dc.b $88,'topstac',$80!'k' cnop 0,2 _topstack dc.l doconstant topstack dc.l 0 * ?stack (s -- ) If the stack under or overflows issue a ; message and abort. dc.w -1 dc.l link3 link3 set *-4 dc.b $86,'?stac',$80!'k' cnop 0,2 _question_stack dc.l nest dc.l _sp_fetch,_sp0,_fetch,_swap dc.l _u_less,_nest_abort_quote dc.b 16,'Stack Underflow',0 cnop 0,2 dc.l _sp_fetch,_topstack,_u_less dc.l _nest_abort_quote dc.b 15,'Stack Overflow',0 cnop 0,2 dc.l _exit * status A deferred word usually set to cr. This word is used in ; the 'quit' loop, when interpreting and can be used to print a status line, ; print a prompt etc. dc.w -1 dc.l link3 link3 set *-4 dc.b $86,'statu',$80!'s' cnop 0,2 _status dc.l dodefer,_cr * interpret (s -- ) The interpret loop, if the next word is defined ; execute it, otherwise convert it to a number and push it onto the stack. ; The loop will end when the end of input is found or when the state ; changes. dc.w -1 dc.l link1 link1 set *-4 dc.b $89,'interpre',$80!'t' cnop 0,2 _interpret dc.l nest 1$ dc.l _question_stack,_defined dc.l _question_branch,2$ dc.l _execute,_branch,3$ 2$ dc.l _number,_double_question,_not dc.l _question_branch,3$ dc.l _drop 3$ dc.l _false,_done_question dc.l _question_branch,1$ dc.l _exit * allot (s n -- ) Allocate n bytes in the dictionary. ; NOTE: be very carefull, allocate only even bytes, or else the guru ; will appear. dc.w -1 dc.l link1 link1 set *-4 dc.b $85,'allo',$80!'t' cnop 0,2 _allot dc.l nest dc.l _dp,_plus_store,_exit * , (s n -- ) Store top of the stack in the dictionary. ; Since this is a 32 bit sytem, 4 bytes are used. dc.w -1 dc.l link0 link0 set *-4 dc.b $81,$80!$2c cnop 0,2 _comma dc.l nest dc.l _here,_store,_4,_allot,_exit * w, (s w -- ) Stores lower 16bits of tos in the dictionary dc.w -1 dc.l link3 link3 set *-4 dc.b $82,'w',$80!$2c cnop 0,2 _w_comma dc.l nest dc.l _here,_w_store,_2,_allot,_exit * c, (s c -- ) Store the character from the tos in the ; dictionary. WARNING must align the dictionary after c, dc.w -1 dc.l link3 link3 set *-4 dc.b $82,'c',$80!$2c cnop 0,2 _c_comma dc.l nest dc.l _here,_c_store,_1,_allot,_exit * align (s -- ) word align the dictionary. dc.w 0 dc.l link1 link1 set *-4 dc.b $85,'alig',$80!'n' cnop 0,2 _align dc.l nest dc.l _here,_1,_and,_question_branch,1$ dc.l _0,_c_comma 1$ dc.l _exit * even (s addr -- addr' ) Force the address on the stack ; to be even. dc.w -1 dc.l link1 link1 set *-4 dc.b $84,'eve',$80!'n' cnop 0,2 _even dc.l nest dc.l _dup,_1,_and,_plus,_exit * compile (s -- ) Compile the following word when this def. ; executes. dc.w -1 dc.l link3 link3 set *-4 dc.b $87,'compil',$80!'e' cnop 0,2 _compile dc.l nest dc.l _r_from,_dup,_4_plus,_to_r dc.l _fetch,_comma,_exit * immediate (s -- ) Mark the last header as immediate. dc.w -1 dc.l link1 link1 set *-4 dc.b $89,'immediat',$80!'e' cnop 0,2 _immediate dc.l nest dc.l _nest_lit,immediate dc.l _last,_fetch,_cset,_exit * literal (s n -- ) compile tos as a literal. dc.w -1 dc.l link0 link0 set *-4 dc.b $87!immediate,'litera',$80!'l' cnop 0,2 _literal dc.l nest dc.l _compile,_nest_lit,_comma,_exit * dliteral (s d -- ) compile the double on the stack as a double lit. dc.w -1 dc.l link0 link0 set *-4 dc.b $88!immediate,'dlitera',$80!'l' cnop 0,2 _dliteral dc.l nest dc.l _swap,_literal,_literal,_exit * ascii (s -- n ) A state smart word. Returns ascii value of the ; following character. If compiling will compile the literal value of the ; character. dc.w -1 dc.l link1 link1 set *-4 dc.b $85!immediate,'asci',$80!'i' cnop 0,2 _ascii dc.l nest dc.l _bl,_word,_1_plus,_c_fetch dc.l _state,_fetch,_question_branch,1$ dc.l _literal 1$ dc.l _exit * control (s -- n ) Same as ascii, but for control characters. dc.w -1 dc.l link3 link3 set *-4 dc.b $87!immediate,'contro',$80!'l' cnop 0,2 _control dc.l nest dc.l _bl,_word,_1_plus,_c_fetch,_nest_lit,31 dc.l _and,_state,_fetch,_question_branch,1$ dc.l _literal 1$ dc.l _exit * crash (s -- ) This routine is the default for deferred words. dc.w -1 dc.l link3 link3 set *-4 dc.b $85,'cras',$80!'h' cnop 0,2 _crash dc.l nest dc.l _true,_nest_abort_quote dc.b 33,' Uninitialized execution vector.',0 cnop 0,2 dc.l _exit * ?missing (s f -- ) This word is executed when the word is not found ; and if it is not convertable to a number. See number. dc.w -1 dc.l link3 link3 set *-4 dc.b $88,'?missin',$80!'g' cnop 0,2 _question_missing dc.l nest dc.l _question_branch,1$ dc.l _tick_word,_count,_type,_true dc.l _nest_abort_quote dc.b 3,' ?',0 cnop 0,2 1$ dc.l _exit * ' (s -- cfa ) returns code field of the following word. dc.w -1 dc.l link3 link3 set *-4 dc.b $81,$80!$27 cnop 0,2 _tick dc.l nest dc.l _defined,_0_equal,_question_missing dc.l _exit * ['] (s -- ) Compiles the cfa of the next word. Used when ; compiling. dc.w -1 dc.l link3 link3 set *-4 dc.b $83!immediate,$5b,$27,$80!$5d cnop 0,2 _bracket_tick dc.l nest dc.l _tick,_literal,_exit * [compile] (s -- ) Force compilation of an immediate word. dc.w -1 dc.l link3 link3 set *-4 dc.b $89!immediate,$5B,'compile',$80!$5d cnop 0,2 _bracket_compile dc.l nest dc.l _tick,_comma,_exit * (") (s -- addr len ) returns address and length of the inline ; string. dc.w -1 dc.l link0 link0 set *-4 dc.b $83,$28,$22,$80!$29 cnop 0,2 _nest_quote dc.l nest dc.l _r_from,_count,_2dup,_plus dc.l _even,_to_r,_exit * (.") (s -- ) Types the inline string. dc.w -1 dc.l link2 link2 set *-4 dc.b $84,$28,$2E,$22,$80!$29 cnop 0,2 _nest_dot_quote dc.l nest dc.l _r_from,_count,_2dup,_plus dc.l _even,_to_r,_type,_exit * ," (s -- ) Adds the text upto the next double quote to the ; dictionary. The text has a null appended, to make it compatible with ; the Amiga. dc.w -1 dc.l link0 link0 set *-4 dc.b $82,$2c,$80!$22 cnop 0,2 _comma_quote dc.l nest dc.l _nest_lit,'"',_parse,_1_plus,_tuck dc.l _tick_word,_place dc.l _allot,_0,_c_comma,_align,_exit * ." (s -- ) Compile the string to be typed out when word ; executes. dc.w -1 dc.l link2 link2 set *-4 dc.b $82!immediate,$2E,$80!$22 cnop 0,2 _dot_quote dc.l nest dc.l _compile,_nest_dot_quote dc.l _comma_quote,_exit * " (s -- ) Compile the string, returns a pointer later. dc.w -1 dc.l link2 link2 set *-4 dc.b $81!immediate,$80!$22 cnop 0,2 _quote dc.l nest dc.l _compile,_nest_quote dc.l _comma_quote,_exit * fenced (S addr -- fl ) True if addr is in userdictionary. ; This word is special, it knows where and how long the userdictionary is. ; This routine is necessary to be able to 'forget' words. The kernel is not ; forgettable and is not sequentially inline with the user dictionary. dc.w -1 dc.l link2 link2 set *-4 dc.b $86,'fence',$80!'d' cnop 0,2 _fenced dc.l *+4 move.l (sp),d0 lea _dp+8,a0 ;point to area after dp sub.l (a0)+,d0 ;the user dictionary start and bmi no ; size are there. sub.l (a0),d0 bmi yes bra no * close-lib (s lib-link -- ) Close the library at the cell before ; this library link. dc.w -1 dc.l link3 link3 set *-4 dc.b $89,'close-li',$80!'b' cnop 0,2 _close_lib dc.l nest dc.l _4_minus,_dup,_fetch,_question_dup dc.l _question_branch,1$ dc.l _CloseLibrary,_off,_branch,2$ 1$ dc.l _drop 2$ dc.l _exit * trim (s faddr voc-addr -- ) Adjusts the 4 linked lists in a ; vocabulary, so they are all less then a specified value, faddr. dc.w -1 dc.l link0 link0 set *-4 dc.b $84,'tri',$80!'m' cnop 0,2 _trim dc.l nest dc.l _number_threads,_0,_nest_do,4$ 1$ dc.l _2dup,_fetch 2$ dc.l _2dup,_dup,_fenced,_minus_rot dc.l _u_greater,_not,_and dc.l _question_branch,3$ dc.l _fetch,_branch,2$ 3$ dc.l _nip,_over,_store,_4_plus dc.l _nest_loop,1$ 4$ dc.l _2drop,_exit * tonext (s faddr linkpointer -- faddr linkpointer flag ) ; Used with forgetting. ; Returns a true flag if the linkpointer is within the fenced area and larger ; than the faddr. dc.w -1 dc.l link0 link0 set *-4 dc.b $86,'tonex',$80!'t' cnop 0,2 _tonext dc.l nest dc.l _2dup,_dup,_fenced,_minus_rot dc.l _u_less,_and,_exit * (forget) (s view-addr -- ) Forgets part of the dictionary. ; Adjusts library links, closing them if necessary, closes files and adjusts ; the file linked list before the words referring to files are forgotten ; and open files are left, requiring a reset. ; If, for some reason, seperate headers are used, the word changes, but ; functionally performs identically. It must release the headers and the ; code. dc.w -1 dc.l link0 link0 set *-4 dc.b $88,'(forget',$80!')' cnop 0,2 _nest_forget dc.l nest dc.l _dup,_fenced,_not dc.l _nest_abort_quote dc.b 12,'Below fence',0 cnop 0,2 dc.l _lib_link,_fetch 1$ dc.l _tonext,_question_branch,2$ dc.l _dup,_close_lib,_fetch,_branch,1$ 2$ dc.l _lib_link,_store ;library links resolved. (s faddr -- ) dc.l _file_link,_fetch 3$ dc.l _tonext,_question_branch,4$ dc.l _dup,_close_file,_fetch,_branch,3$ 4$ dc.l _file_link,_store ;file links resolved (s faddr -- ) dc.l _voc_link,_fetch 5$ dc.l _tonext,_question_branch,6$ dc.l _fetch,_branch,5$ 6$ dc.l _dup,_voc_link,_store 7$ dc.l _dup,_question_branch,8$ dc.l _2dup,_number_threads,_4_times dc.l _minus,_trim,_fetch,_branch,7$ 8$ dc.l _drop,_dp,_store,_exit * forget (s -- ) <word> ; Forgets all headers and code before <word>. dc.w -1 dc.l link2 link2 set *-4 dc.b $86,'forge',$80!'t' cnop 0,2 _forget dc.l nest dc.l _bl,_word,_question_uppercase,_dup dc.l _current,_fetch,_hash,_fetch,_nest_find dc.l _0_equal,_question_missing,_to_view dc.l _nest_forget,_exit * close-libs (s -- ) Close all libraries by traversing the linked list ; and close any library which is open. Called by bye. dc.w -1 dc.l link3 link3 set *-4 dc.b $8A,'close-lib',$80!'s' cnop 0,2 _close_libs dc.l nest dc.l _lib_link 1$ dc.l _fetch,_question_dup,_question_branch,2$ dc.l _dup,_close_lib dc.l _branch,1$ 2$ dc.l _exit * where A deferred word, currently (where), prints all the ; loadbuffers, unnesting the loading process. dc.w -1 dc.l link3 link3 set *-4 dc.b $85,'wher',$80!'e' cnop 0,2 _where dc.l dodefer,_nest_where * (where) (s index -- ) Print out the loadbuffer, index is where ; the loading problem occured. Print all the buffers nested. dc.w -1 dc.l link0 link0 set *-4 dc.b $87,'(where',$80!')' cnop 0,2 _nest_where dc.l nest dc.l _lb,_fetch,_4_plus,_count,_cr,_type,_cr dc.l _spaces,_nest_lit,$5E,_emit,_cr 1$ dc.l _droplb,_lb,_fetch,_question_dup dc.l _question_branch,2$ dc.l _4_plus,_count,_type,_cr,_branch,1$ 2$ dc.l _exit * ?error Deferred word, currently (?error). Abort ends up here ; change this to alter aborts behaviour. dc.w -1 dc.l link3 link3 set *-4 dc.b $86,'?erro',$80!'r' cnop 0,2 _question_error dc.l dodefer,_nest_question_error * (?error) (s addr len f -- ) Conditionally type the string and if ; input is from the disk, execute where. dc.w -1 dc.l link0 link0 set *-4 dc.b $88,'(?error',$80!')' cnop 0,2 _nest_question_error dc.l nest dc.l _question_branch,2$ dc.l _to_r,_to_r,_sp0,_fetch,_sp_store dc.l _loading,_fetch,_question_branch,1$ dc.l _to_in,_fetch,_where 1$ dc.l _r_from,_r_from,_space,_type,_space dc.l _quit,_branch,3$ 2$ dc.l _2drop 3$ dc.l _exit * (abort") (s f -- ) Runtime for abort", calls ?error and ; adjusts the stack dc.w -1 dc.l link0 link0 set *-4 dc.b $88,'(abort"',$80!')' cnop 0,2 _nest_abort_quote dc.l nest dc.l _r_fetch,_count,_rot,_question_error dc.l _r_from,_count,_plus,_even,_to_r dc.l _exit * abort" (s -- ) Compiles a string to be typed if the flag is ; true and then quits by running quit. dc.w -1 dc.l link1 link1 set *-4 dc.b $86!immediate,'abort',$80!'"' cnop 0,2 _abort_quote dc.l nest dc.l _compile,_nest_abort_quote dc.l _comma_quote,_exit * abort (s -- ) Stop the system. dc.w -1 dc.l link1 link1 set *-4 dc.b $85,'abor',$80!'t' cnop 0,2 _abort dc.l nest dc.l _true,_nest_abort_quote dc.b 1,0 cnop 0,2 dc.l _exit